home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 3: CDPD 3 / Almathera Ten on Ten - Disc 3: CDPD3.iso / fish / 001-100 / 001-025 / 018 / xlisp1.6 / hdwr.lsp < prev    next >
Lisp/Scheme  |  1995-03-17  |  9KB  |  310 lines
  1. ; -*-Lisp-*-
  2. ;
  3. ; Jwahar R. Bammi
  4. ; A simple description of hardware objects using xlisp
  5. ; Mix and match instances of the objects to create your
  6. ; organization.
  7. ; Needs:
  8. ; - busses and connection and the Design
  9. ;   Class that will have the connections as instance vars.
  10. ; - Print method for each object, that will display
  11. ;   the instance variables in an human readable form.
  12. ; Some day I will complete it.
  13. ;
  14. ;
  15. ;
  16. ; utility functions
  17.  
  18.  
  19. ; function to calculate 2^n
  20.  
  21. (defun pow2 (n)
  22.     (pow2x n 1))
  23.  
  24. (defun pow2x (n sum)
  25.        (cond((equal n 0) sum)
  26.         (t (pow2x (- n 1) (* sum 2)))))
  27.  
  28.  
  29. ; hardware objects
  30.  
  31. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  32. ;The class areg
  33.  
  34. (setq areg (Class :new '(value nbits max_val min_val)))
  35.  
  36. ; methods
  37.  
  38. ; initialization method
  39. ; when a new instance is called for the user supplies
  40. ; the parameter nbits, from which the max_val & min_val are derived
  41.  
  42. (areg :answer :isnew '(n)
  43.       '((self :init n)
  44.             self))
  45.  
  46. (areg :answer :init '(n)
  47.       '((setq value ())
  48.         (setq nbits n)
  49.         (setq max_val (- (pow2 (- n 1)) 1))
  50.         (setq min_val (- (- 0 max_val) 1))))
  51.  
  52. ; load areg
  53.  
  54. (areg :answer :load '(val)
  55.       '((cond ((> val max_val) (princ (list "The max value a "nbits" bit register can hold is "max_val"\n")))
  56.           ((< val min_val) (princ (list "The min value a "nbits" bit register can hold is "min_val"\n")))
  57.           (t (setq value val)))))
  58.  
  59. ; see areg
  60.  
  61. (areg :answer :see '()
  62.       '((cond ((null value) (princ "Register does not contain a value\n"))
  63.           (t value))))
  64. ;
  65. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  66.  
  67. ; The class creg ( a register that can be cleared and incremented)
  68. ; subclass of a reg
  69.  
  70. (setq creg (Class :new '() '() areg))
  71.  
  72. ; it inherites all the instance vars & methods of a reg
  73. ; in addition to them it has the following methods
  74.  
  75. (creg :answer :isnew '(n)
  76.       '((self :init n)
  77.     self))
  78.  
  79. (creg :answer :init '(n)
  80.       '((setq value ())
  81.     (setq nbits n)
  82.     (setq max_val (- (pow2 n) 1))
  83.     (setq min_val 0)))
  84.  
  85. (creg :answer :clr '()
  86.       '((setq value 0)))
  87.  
  88. (creg :answer :inc '()
  89.       '((cond ((null value) (princ "Register does not contain a value\n"))
  90.           (t (setq value (rem (+ value 1) (+ max_val 1)))))))
  91.  
  92. ;
  93. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  94. ;
  95. ; Register bank
  96. ; contains n areg's n_bits each
  97.  
  98. (setq reg_bank (Class :new '(regs n_regs curr_reg)))
  99.  
  100. ;methods
  101.  
  102. (reg_bank :answer :isnew '(n n_bits)
  103.       '((self :init n n_bits)
  104.         self))
  105.  
  106. (reg_bank :answer :init '(n n_bits)
  107.       '((setq regs ())
  108.         (setq n_regs (- n 1))
  109.         (self :initx n n_bits)))
  110.  
  111. (reg_bank :answer :initx '(n n_bits)
  112.       '((cond ((equal n 0) t)
  113.               (t (list (setq regs (cons (areg :new n_bits) regs))
  114.           (self :initx (setq n (- n 1)) n_bits))))))
  115.  
  116. (reg_bank :answer :load '(reg val)
  117.       '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
  118.          (t (setq curr_reg (nth (+ reg 1) regs))
  119.             (curr_reg :load val)))))
  120.  
  121. (reg_bank :answer :see '(reg)
  122.       '((cond((> reg n_regs) (princ (list "Only "(+ 1 n_regs)" registers instantiated\n")))
  123.          (t (setq curr_reg (nth (+ reg 1) regs))
  124.             (curr_reg :see)))))
  125. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  126. ; The Class alu
  127.  
  128. ;alu - an n bit alu
  129.  
  130. (setq alu (Class :new '(n_bits maxs_val mins_val maxu_val minu_val nf zf vf cf)))
  131.  
  132. ; methods
  133.  
  134. (alu :answer :isnew '(n)
  135.      '((self :init n)
  136.        self))
  137.  
  138. (alu :answer :init '(n)
  139.      '((setq n_bits n)
  140.        (setq maxu_val (- (pow2 n) 1))
  141.        (setq maxs_val (- (pow2 (- n 1)) 1))
  142.        (setq mins_val (- (- 0 maxs_val) 1))
  143.        (setq minu_val 0)
  144.        (setq nf 0)
  145.        (setq zf 0)
  146.        (setq vf 0)
  147.        (setq cf 0)))
  148.  
  149. (alu :answer :check_arith '(a b)
  150.      '((cond ((and (self :arith_range a) (self :arith_range b)) t)
  151.          (t ()))))
  152.  
  153. (alu :answer :check_logic '(a b)
  154.      '((cond ((and (self :logic_range a) (self :logic_range b)) t)
  155.          (t ()))))
  156.  
  157. (alu :answer :arith_range '(a)
  158.      '((cond ((< a mins_val) (princ (list "Operand out of Range "a"\n")))
  159.          ((> a maxs_val) (princ (list "Operand out of range "a"\n")))
  160.              (t t))))
  161.  
  162. (alu :answer :logic_range '(a)
  163.      '((cond ((< (abs a) minu_val) (princ (list "Operand out of Range "a"\n")))
  164.              (t t))))
  165.  
  166. (alu :answer :set_flags '(a b r)
  167.      '((if (equal 0 r) ((setq zf 1)))
  168.        (if (< r 0) ((setq nf 1)))
  169.        (if (or (and (and (< a 0) (< 0 b)) (>= r 0))
  170.           (and (and (>= a 0) (>= b 0)) (< r 0))) ((setq vf 1)))
  171.        (if (or (or (and (< a 0) (< b 0)) (and (< a 0) (>= r 0)))
  172.           (and (>= r 0) (< b 0))) ((setq cf 1)))))
  173.        
  174. (alu :answer :+ '(a b &aux result)
  175.      '((cond ((null (self :check_arith a b)) ())
  176.         (t (self :clear_flags)
  177.            (setq result (+ a b))
  178.            (if (> result maxs_val) ((setq result (+ (- (rem result maxs_val) 1) mins_val))))
  179.            (if (< result mins_val) ((setq result (+ (rem result mins_val) (+ maxs_val 1)))))
  180.            (self :set_flags a b result)
  181.            result))))
  182.  
  183. (alu :answer :& '(a b &aux result)
  184.      '((cond ((null (self :check_logic a b)) ())
  185.         (t (self :clear_flags)
  186.            (setq result (bit-and a b))
  187.            (self :set_flags a b result)
  188.            result))))
  189.  
  190. (alu :answer :| '(a b &aux result)
  191.      '((cond ((null (self :check_logic a b)) ())
  192.         (t (self :clear_flags)
  193.            (setq result (bit-ior a b))
  194.            (self :set_flags a b result)
  195.            result))))
  196.  
  197. (alu :answer :~ '(a  &aux result)
  198.      '((cond ((null (self :check_logic a 0)) ())
  199.         (t (self :clear_flags)
  200.            (setq result (bit-not a))
  201.            (self :set_flags a 0 result)
  202.            result))))           
  203.  
  204. (alu :answer :- '(a b)
  205.      '((self '+ a (- 0 b))))
  206.  
  207. (alu :answer :passa '(a)
  208.      '(a))
  209.  
  210. (alu :answer :zero '()
  211.      '(0))
  212.  
  213. (alu :answer :com '(a)
  214.      '((self :- 0 a)))
  215.  
  216. (alu :answer :status '()
  217.      '((princ (list "NF "nf"\n"))
  218.        (princ (list "ZF "zf"\n"))
  219.        (princ (list "CF "cf"\n"))
  220.        (princ (list "VF "vf"\n"))))
  221.  
  222. (alu :answer :clear_flags '()
  223.      '((setq nf 0)
  224.        (setq zf 0)
  225.        (setq cf 0)
  226.        (setq vf 0)))
  227.  
  228. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  229. ;
  230. ; The class Memory
  231. ;
  232.  
  233. (setq memory (Class :new '(nabits ndbits maxu_val maxs_val mins_val max_addr undef memry)))
  234.  
  235. ; methods
  236.  
  237. (memory :answer :isnew '(addr_bits data_bits)
  238.      '((self :init addr_bits data_bits)
  239.        self))
  240.  
  241. (memory :answer :init '(addr_bits data_bits)
  242.      '((setq nabits addr_bits)
  243.        (setq ndbits data_bits)
  244.        (setq maxu_val (- (pow2 data_bits) 1))
  245.        (setq max_addr (- (pow2 addr_bits) 1))
  246.        (setq maxs_val (- (pow2 (- data_bits 1)) 1))
  247.        (setq mins_val (- 0 (pow2 (- data_bits 1))))
  248.        (setq undef (+ maxu_val 1))
  249.        (setq memry (array :new max_addr undef))))
  250.  
  251.  
  252. (memory :answer :load '(loc val)
  253.      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
  254.          ((< val 0) (princ (list "Cant store "val" in "ndbits" bits\n")))
  255.          ((> val maxu_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
  256.          (t (memry :load loc val)))))
  257.  
  258. (memory :answer :write '(loc val)
  259.      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
  260.          ((> val maxs_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
  261.          ((< val mins_val) (princ (list "Cant store "val" in "ndbits" bits\n")))
  262.          (t (memry :load loc val)))))
  263.  
  264.  
  265. (memory :answer :read '(loc &aux val)
  266.      '((cond ((> (abs loc) max_addr) (princ (list "Address "loc" out of range\n")))
  267.          (t (setq val (memry :see loc))
  268.         (cond ((equal undef val) (princ (list "Address "loc" read before write\n")))
  269.               (t val))))))
  270.  
  271.  
  272. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  273. ;
  274. ; The class array
  275.  
  276. (setq array (Class :new '(arry)))
  277.  
  278. ; methods
  279.  
  280. (array :answer :isnew '(n val)
  281.        '((self :init n val)
  282.      self))
  283.  
  284. (array :answer :init '(n val)
  285.     '((cond ((< n 0) t)
  286.           (t (setq arry (cons val arry))
  287.          (self :init (- n 1) val)))))
  288.  
  289. (array :answer :see '(n)
  290.            '((nth (+ n 1) arry)))
  291.  
  292.  
  293. (array :answer :load '(n val &aux left right temp)
  294.        '((setq left (self :left_part n arry temp))
  295.      (setq right (self :right_part n arry))
  296.      (setq arry (append left (list val)))
  297.      (setq arry (append arry right))
  298.      val))
  299.  
  300. (array :answer :left_part '(n ary left)
  301.        '((cond ((equal n 0) (reverse left))
  302.            (t (setq left (cons (car ary) left))
  303.           (self :left_part (- n 1) (cdr ary) left)))))
  304.  
  305. (array :answer :right_part '(n ary &aux right)
  306.        '((cond ((equal n 0) (cdr ary))
  307.            (t (self :right_part (- n 1) (cdr ary))))))
  308.  
  309. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  310.